home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
DB_CLIPP
/
H245.ZIP
/
NFSRC21.ZIP
/
XBOX.PRG
< prev
next >
Wrap
Text File
|
1991-08-17
|
9KB
|
229 lines
/*
* File......: XBOX.PRG
* Author....: Don Opperthauser
* Date......: $Date: 17 Aug 1991 15:47:06 $
* Revision..: $Revision: 1.3 $
* Log file..: $Logfile: E:/nanfor/src/xbox.prv $
*
* This is an original work by Don Opperthauser and is placed in the
* public domain.
*
* Modification history:
* ---------------------
*
* $Log: E:/nanfor/src/xbox.prv $
*
* Rev 1.3 17 Aug 1991 15:47:06 GLENN
* Don Caton fixed some spelling errors in the doc
*
* Rev 1.2 15 Aug 1991 23:05:12 GLENN
* Forest Belt proofread/edited/cleaned up doc
*
* Rev 1.1 14 Jun 1991 17:55:50 GLENN
* Fixed bug where extra blank line was displayed in the box.
*
* Rev 1.0 01 Apr 1991 01:02:34 GLENN
* Nanforum Toolkit
*
*/
/* $DOC$
* $FUNCNAME$
* FT_XBOX()
* $CATEGORY$
* Menus/Prompts
* $ONELINER$
* Display a self-sizing message box and message
* $SYNTAX$
* FT_XBOX( [ <cJustType> ], [ <cRetWait> ], [ <cBorType> ], ;
* [ <cBorColor> ], [ <cBoxColor> ], [ <nStartRow> ], ;
* [ <nStartCol> ], <cLine1>, <cLine2>, <cLine3>, ;
* <cLine4>, <cLine5>, <cLine6>, <cLine7>, <cLine8> ) -> NIL
* $ARGUMENTS$
* <cJustType> is a character indicating the type of text justification.
* "L" or "l" will cause the text to be left-justified in the box.
* Centered text is the default.
*
* <cRetWait> is a character which determines if the function will wait
* for a keypress after displaying the box. "W" or "w" will cause the
* function to wait for a keypress before returning control to the
* calling routine. Not waiting is the default
*
* <cBorType> is a character which determines whether a single or double
* border will be displayed. "D" or "d" will cause a double border to
* be displayed. A single border is the default.
*
* <cBorColor> is a character string denoting the border color. 'N/W' is
* the default if this parameter is not a string.
*
* <cBoxColor> is a character string denoting the text color. 'W/N' is
* the default if this parameter is not a string.
*
* <nStartRow> is a number denoting the starting row. If '99' is passed,
* the box is centered vertically. If necessary, nStartRow is decreased
* so the entire box can be displayed.
*
* <nStartCol> is a number denoting the starting column. If '99' is passed,
* the box is centered horizontally. If necessary, nStartCol is decreased
* so the entire box can be displayed.
*
* <cLine1> thru <cLine8> are 1 to 8 character strings to be displayed.
* They are truncated to fit on the screen if necessary.
* $RETURNS$
* NIL
* $DESCRIPTION$
* FT_XBOX() allows the programmer to display a message box on the screen
* without needing to calculate the dimensions of the box. Only the upper
* left corner needs to be defined. The function will calculate the lower
* right corner based on the number and length of strings passed.
*
* A maximum of eight strings can be displayed. If a string is too long
* to fit on the screen it is truncated.
*
* The first seven parameters are optional. The default settings are:
* Lines of text are centered.
* Control is returned to the calling routine immediately.
* A single line border is painted.
* The border is black on white.
* The text is white on black.
* The box is centered both vertically and horizontally.
*
* WARNING: Shadowing is achieved by a call to FT_SHADOW(), an assembly
* routine not found in this .PRG. In order to use XBOX,
* SHADOW.OBJ must also be present somewhere (if you are using
* NANFOR.LIB, then it is).
* $EXAMPLES$
* The following displays a two-line box with default settings:
*
* FT_XBOX(,,,,,,,'This is a test','of the XBOX() function')
*
* The following uses all optional parameters and displays a three-line
* box. The box is left-justified with a double border. It has a yellow
* on red border and white on blue text. The function will wait for a
* keypress before returning control to the calling routine.
*
* FT_XBOX('L','W','D','GR+/R','W/B',5,10,'It is so nice',;
* 'to not have to do the messy chore',;
* 'of calculating the box size!')
* $END$
*/
#ifdef FT_TEST
FUNCTION MAIN()
local i
setcolor('W/B')
* clear screen
for i = 1 to 24
@ i, 0 say replicate('@', 80)
next
FT_XBOX(,,,,,,,'This is a test','of the XBOX() function')
FT_XBOX('L','W','D','GR+/R','W/B',1,10,'It is so nice',;
'to not have to do the messy chore',;
'of calculating the box size!')
FT_XBOX(,'W','D','GR+/R','W/B',16,10,'It is so nice',;
'to not have to do the messy chore',;
'of calculating the box size!',;
'Even though this line is way too long, and is in fact more than 80 characters long, if you care to check!')
return ( nil )
#endif
FUNCTION FT_XBOX(cJustType,; // "L" = left, otherwise centered
cRetWait, ; // "W" = wait for keypress before continuing
cBorType, ; // "D" = double, anything else single border
cBorColor,; // color string for border
cBoxColor,; // color string for text
nStartRow,; // upper row of box. 99=center vertically
nStartCol,; // left edge of box. 99=center horizontally
cLine1, cLine2, cLine3, cLine4, cLine5, cLine6, cLine7, cLine8)
LOCAL nLLen := 0, ;
cOldColor, ;
nLCol, ;
nRCol, ;
nTRow, ;
nBRow, ;
nLoop, ;
cSayStr, ;
nSayRow, ;
nSayCol, ;
nNumRows, ;
aLines_[8]
// validate parameters
cJustType := if(ValType(cJustType)='C',Upper(cJustType),'')
cRetWait := if(ValType(cRetWait )='C',Upper(cRetWait), '')
cBorType := if(ValType(cBorType )='C',Upper(cBorType), '')
cBorColor := if(ValType(cBoxColor)='C',cBorColor, 'N/W')
cBoxColor := if(ValType(cBoxColor)='C',cBoxColor, 'W/N')
nStartRow := if(ValType(nStartRow)='N',nStartRow,99)
nStartCol := if(ValType(nStartCol)='N',nStartCol,99)
nNumRows := Min(PCount()-7,8)
//establish array of strings to be displayed
aLines_[1] := if(ValType(cLine1) = 'C',AllTrim(SubStr(cLine1,1,74)),'')
aLines_[2] := if(ValType(cLine2) = 'C',AllTrim(SubStr(cLine2,1,74)),'')
aLines_[3] := if(ValType(cLine3) = 'C',AllTrim(SubStr(cLine3,1,74)),'')
aLines_[4] := if(ValType(cLine4) = 'C',AllTrim(SubStr(cLine4,1,74)),'')
aLines_[5] := if(ValType(cLine5) = 'C',AllTrim(SubStr(cLine5,1,74)),'')
aLines_[6] := if(ValType(cLine6) = 'C',AllTrim(SubStr(cLine6,1,74)),'')
aLines_[7] := if(ValType(cLine7) = 'C',AllTrim(SubStr(cLine7,1,74)),'')
aLines_[8] := if(ValType(cLine8) = 'C',AllTrim(SubStr(cLine8,1,74)),'')
ASize(aLines_,Min(nNumRows,8))
// determine longest line
nLoop := 1
AEVAL(aLines_,{|| nLLen:=Max(nLLen,Len(aLines_[nLoop])),nLoop++})
// calculate corners
nLCol = if(nStartCol=99,Int((76-nLLen)/2),Min(nStartCol,74-nLLen))
nRCol = nLCol+nLLen+3
nTRow = if(nStartRow=99,INT((24-nNumRows)/2),Min(nStartRow,22-nNumRows))
nBRow = nTRow+nNumRows+1
// form box and border
// save screen color and set new color
cOldColor = SetColor(cBoxColor)
@ nTRow,nLCol Clear to nBRow,nRCol
// draw border
SetColor(cBorColor)
IF cBorType = "D"
@ nTRow,nLCol TO nBRow,nRCol double
ELSE
@ nTRow,nLCol TO nBRow,nRCol
ENDIF
// write shadow
FT_SHADOW(nTRow,nLCol,nBRow,nRCol)
// print text in box
SetColor(cBoxColor)
nLoop :=1
AEVAL(aLines_,{|cSayStr|;
nSayRow := nTRow+nLoop,;
nSayCol := if(cJustType = 'L',;
nLCol+2,;
nLCol+2+(nLLen-Int(Len(aLines_[nLoop])))/2),;
nLoop++,;
_FTSAY(nSayRow,nSayCol,cSayStr);
})
// wait for keypress if desired
IF cRetWait ='W'
Inkey(0)
ENDIF
RETURN NIL
STATIC FUNCTION _FTSAY(nSayRow,nSayCol,cSayStr)
@ nSayRow,nSayCol SAY cSayStr
RETURN NIL